home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / c-call.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  2.6 KB  |  89 lines
  1. ;;; -*- Package: C-CALL -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: c-call.lisp,v 1.11 92/03/04 17:08:52 ram Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; This file contains some extensions to the Alien facility to simplify
  15. ;;; importing C interfaces.
  16. ;;;
  17. (in-package "C-CALL")
  18. (use-package "ALIEN")
  19. (use-package "ALIEN-INTERNALS")
  20. (use-package "SYSTEM")
  21.  
  22. (export '(char short int long unsigned-char unsigned-short unsigned-int
  23.       unsigned-long float double c-string void))
  24.            
  25.  
  26. ;;;; Extra types.
  27.  
  28. (def-alien-type char (integer 8))
  29. (def-alien-type short (integer 16))
  30. (def-alien-type int (integer 32))
  31. (def-alien-type long (integer 32))
  32.  
  33. (def-alien-type unsigned-char (unsigned 8))
  34. (def-alien-type unsigned-short (unsigned 16))
  35. (def-alien-type unsigned-int (unsigned 32))
  36. (def-alien-type unsigned-long (unsigned 32))
  37.  
  38. (def-alien-type float single-float)
  39. (def-alien-type double double-float)
  40.  
  41. (def-alien-type-translator void ()
  42.   (parse-alien-type '(values)))
  43.  
  44.  
  45.  
  46. ;;;; C string support.
  47.  
  48. (def-alien-type-class (c-string :include pointer))
  49.  
  50. (def-alien-type-translator c-string ()
  51.   (make-alien-c-string-type :to (parse-alien-type 'char)))
  52.  
  53. (def-alien-type-method (c-string :unparse) (type)
  54.   (declare (ignore type))
  55.   'c-string)
  56.  
  57. (def-alien-type-method (c-string :lisp-rep) (type)
  58.   (declare (ignore type))
  59.   '(or simple-base-string null (alien (* char))))
  60.  
  61. (def-alien-type-method (c-string :naturalize-gen) (type alien)
  62.   (declare (ignore type))
  63.   `(if (zerop (sap-int ,alien))
  64.        nil
  65.        (%naturalize-c-string ,alien)))
  66.  
  67. (def-alien-type-method (c-string :deport-gen) (type value)
  68.   (declare (ignore type))
  69.   `(etypecase ,value
  70.      (null (int-sap 0))
  71.      ((alien (* char)) (alien-sap ,value))
  72.      (simple-base-string (vector-sap ,value))))
  73.  
  74. (defun %naturalize-c-string (sap)
  75.   (declare (type system-area-pointer sap))
  76.   (with-alien ((ptr (* char) sap))
  77.     (locally
  78.      (declare (optimize (speed 3) (safety 0)))
  79.      (let ((length (loop
  80.              for offset of-type fixnum upfrom 0
  81.              until (zerop (deref ptr offset))
  82.              finally return offset)))
  83.        (let ((result (make-string length)))
  84.      (kernel:copy-from-system-area (alien-sap ptr) 0
  85.                        result (* vm:vector-data-offset
  86.                          vm:word-bits)
  87.                        (* length vm:byte-bits))
  88.      result)))))
  89.